home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DIRS.SWG / 0039_Select DIR progarm.pas < prev    next >
Pascal/Delphi Source File  |  1995-02-28  |  12KB  |  484 lines
  1.  
  2. Program DIRSEL;
  3. Uses
  4.   Crt,Dos; { ** needed for DIRSELECT functions ** }
  5.  
  6. { ** The following Type & Var declarations are for the main program only ** }
  7. { ** However, the string length of the returned parameter from DIRSELECT ** }
  8. { ** must be a least 12 characters.  ** }
  9.  
  10. Type
  11.   strtype = String[12];
  12. Var
  13.   spec,fname : strtype;
  14.  
  15. { ************************************************************************** }
  16. { ** List of Procedures/Functions needed for DIRSELECT** }
  17. { ** Procedure CURSOR - turns cursor on or off** }
  18. { ** Procedure FRAME - draws single or double frame ** }
  19. { ** Function ISCOLOR - returns the current video mode** }
  20. { ** Procedure SAVESCR- saves current video screen** }
  21. { ** Procedure RESTORESCR - restores old video screen ** }
  22. { ** Procedure SCRGET - get character/attribute  ** }
  23. { ** Procedure SCRPUT - put character/attribute  ** }
  24. { ** Procedure FNAMEPOS  - finds proper screen position ** }
  25. { ** Procedure HILITE - highlights proper name** }
  26. { ** Function DIRSELECT  - directory selector** }
  27. { ************************************************************************** }
  28.  
  29. Procedure CURSOR( attrib : Boolean );
  30. Var
  31.   regs : Registers;
  32. Begin
  33.   If NOT attrib Then { turn cursor off }
  34.   Begin
  35.  regs.ah := 1;
  36.  regs.cl := 7;
  37.  regs.ch := 32;
  38.  Intr($10,regs)
  39.   End
  40.   Else { turn cursor on }
  41.   Begin
  42.  Intr($11,regs);
  43.  regs.cx := $0607;
  44.  If regs.al AND $10 <> 0 Then regs.cx := $0B0C;
  45.  regs.ah := 1;
  46.  Intr($10,regs)
  47.   End
  48. End;
  49.  
  50. Procedure FRAME(t,l,b,r,ftype : Integer);
  51. Var
  52.   i : Integer;
  53. Begin
  54.   GoToXY(l,t);
  55.   If ftype = 2 Then
  56.  Write(Chr(201))
  57.   Else
  58.  Write(Chr(218));
  59.   GoToXY(r,t);
  60.   If ftype = 2 Then
  61.  Write(Chr(187))
  62.   Else
  63.  Write(Chr(191));
  64.   GoToXY(l+1,t);
  65.   For i := 1 To (r - (l + 1)) Do
  66.  If ftype = 2 Then
  67.  Write(Chr(205))
  68.  Else
  69.  Write(Chr(196));
  70.   GoToXY(l+1,b);
  71.   For i := 1 To (r - (l + 1)) Do
  72.  If ftype = 2 Then
  73.  Write(Chr(205))
  74.  Else
  75.  Write(Chr(196));
  76.   GoToXY(l,b);
  77.   If ftype = 2 Then
  78.  Write(Chr(200))
  79.   Else
  80.  Write(Chr(192));
  81.   GoToXY(r,b);
  82.   If ftype = 2 Then
  83.  Write(Chr(188))
  84.   Else
  85.  Write(Chr(217));
  86.   For i := (t+1) To (b-1) Do
  87.   Begin
  88.  GoToXY(l,i);
  89.  If ftype = 2 Then
  90.  Write(Chr(186))
  91.  Else
  92.  Write(Chr(179))
  93.   End;
  94.   For i := (t+1) To (b-1) Do
  95.   Begin
  96.  GoToXY(r,i);
  97.  If ftype = 2 Then
  98.  Write(Chr(186))
  99.  Else
  100.  Write(Chr(179))
  101.   End
  102. End;
  103.  
  104. Function ISCOLOR : Boolean; { returns FALSE for MONO or TRUE for COLOR }
  105. Var
  106.   regs  : Registers;
  107.   video_mode : Integer;
  108.   equ_lo : Byte;
  109. Begin
  110.   Intr($11,regs);
  111.   video_mode := regs.al and $30;
  112.   video_mode := video_mode shr 4;
  113.   Case video_mode of
  114.  1 : ISCOLOR := FALSE; { Monochrome }
  115.  2 : ISCOLOR := TRUE{ Color }
  116.   End
  117. End;
  118.  
  119. Procedure SAVESCR( Var screen );
  120. Var
  121.   vidc : Byte Absolute $B800:0000;
  122.   vidm : Byte Absolute $B000:0000;
  123. Begin
  124.   If NOT ISCOLOR Then { if MONO }
  125.  Move(vidm,screen,4000)
  126.   Else { else COLOR }
  127.  Move(vidc,screen,4000)
  128. End;
  129.  
  130. Procedure RESTORESCR( Var screen );
  131. Var
  132.   vidc : Byte Absolute $B800:0000;
  133.   vidm : Byte Absolute $B000:0000;
  134. Begin
  135.   If NOT ISCOLOR Then { if MONO }
  136.  Move(screen,vidm,4000)
  137.   Else { else COLOR }
  138.  Move(screen,vidc,4000)
  139. End;
  140.  
  141. Procedure SCRGET( Var ch,attr : Byte );
  142. Var
  143.   regs : Registers;
  144. Begin
  145.   regs.bh := 0;
  146.   regs.ah := 8;
  147.   Intr($10,regs);
  148.   ch := regs.al;
  149.   attr := regs.ah
  150. End;
  151.  
  152. Procedure SCRPUT( ch,attr : Byte );
  153. Var
  154.   regs : Registers;
  155. Begin
  156.   regs.al := ch;
  157.   regs.bl := attr;
  158.   regs.ch := 0;
  159.   regs.cl := 1;
  160.   regs.bh := 0;
  161.   regs.ah := 9;
  162.   Intr($10,regs);
  163. End;
  164.  
  165. Procedure FNAMEPOS(Var arypos,x,y : Integer);
  166. { determine position on screen of filename }
  167. Const
  168.   FPOS1 = 2;
  169.   FPOS2 = 15;
  170.   FPOS3 = 28;
  171.   FPOS4 = 41;
  172.   FPOS5 = 54;
  173.   FPOS6 = 67;
  174. Begin
  175.   Case arypos of
  176. 1: Begin x := FPOS1; y := 2 End;
  177. 2: Begin x := FPOS2; y := 2 End;
  178. 3: Begin x := FPOS3; y := 2 End;
  179. 4: Begin x := FPOS4; y := 2 End;
  180. 5: Begin x := FPOS5; y := 2 End;
  181. 6: Begin x := FPOS6; y := 2 End;
  182. 7: Begin x := FPOS1; y := 3 End;
  183. 8: Begin x := FPOS2; y := 3 End;
  184. 9: Begin x := FPOS3; y := 3 End;
  185.   10: Begin x := FPOS4; y := 3 End;
  186.   11: Begin x := FPOS5; y := 3 End;
  187.   12: Begin x := FPOS6; y := 3 End;
  188.   13: Begin x := FPOS1; y := 4 End;
  189.   14: Begin x := FPOS2; y := 4 End;
  190.   15: Begin x := FPOS3; y := 4 End;
  191.   16: Begin x := FPOS4; y := 4 End;
  192.   17: Begin x := FPOS5; y := 4 End;
  193.   18: Begin x := FPOS6; y := 4 End;
  194.   19: Begin x := FPOS1; y := 5 End;
  195.   20: Begin x := FPOS2; y := 5 End;
  196.   21: Begin x := FPOS3; y := 5 End;
  197.   22: Begin x := FPOS4; y := 5 End;
  198.   23: Begin x := FPOS5; y := 5 End;
  199.   24: Begin x := FPOS6; y := 5 End;
  200.   25: Begin x := FPOS1; y := 6 End;
  201.   26: Begin x := FPOS2; y := 6 End;
  202.   27: Begin x := FPOS3; y := 6 End;
  203.   28: Begin x := FPOS4; y := 6 End;
  204.   29: Begin x := FPOS5; y := 6 End;
  205.   30: Begin x := FPOS6; y := 6 End;
  206.   31: Begin x := FPOS1; y := 7 End;
  207.   32: Begin x := FPOS2; y := 7 End;
  208.   33: Begin x := FPOS3; y := 7 End;
  209.   34: Begin x := FPOS4; y := 7 End;
  210.   35: Begin x := FPOS5; y := 7 End;
  211.   36: Begin x := FPOS6; y := 7 End;
  212.   37: Begin x := FPOS1; y := 8 End;
  213.   38: Begin x := FPOS2; y := 8 End;
  214.   39: Begin x := FPOS3; y := 8 End;
  215.   40: Begin x := FPOS4; y := 8 End;
  216.   41: Begin x := FPOS5; y := 8 End;
  217.   42: Begin x := FPOS6; y := 8 End;
  218.   43: Begin x := FPOS1; y := 9 End;
  219.   44: Begin x := FPOS2; y := 9 End;
  220.   45: Begin x := FPOS3; y := 9 End;
  221.   46: Begin x := FPOS4; y := 9 End;
  222.   47: Begin x := FPOS5; y := 9 End;
  223.   48: Begin x := FPOS6; y := 9 End;
  224.   49: Begin x := FPOS1; y := 10 End;
  225.   50: Begin x := FPOS2; y := 10 End;
  226.   51: Begin x := FPOS3; y := 10 End;
  227.   52: Begin x := FPOS4; y := 10 End;
  228.   53: Begin x := FPOS5; y := 10 End;
  229.   54: Begin x := FPOS6; y := 10 End;
  230.   55: Begin x := FPOS1; y := 11 End;
  231.   56: Begin x := FPOS2; y := 11 End;
  232.   57: Begin x := FPOS3; y := 11 End;
  233.   58: Begin x := FPOS4; y := 11 End;
  234.   59: Begin x := FPOS5; y := 11 End;
  235.   60: Begin x := FPOS6; y := 11 End;
  236.   61: Begin x := FPOS1; y := 12 End;
  237.   62: Begin x := FPOS2; y := 12 End;
  238.   63: Begin x := FPOS3; y := 12 End;
  239.   64: Begin x := FPOS4; y := 12 End;
  240.   65: Begin x := FPOS5; y := 12 End;
  241.   66: Begin x := FPOS6; y := 12 End;
  242.   67: Begin x := FPOS1; y := 13 End;
  243.   68: Begin x := FPOS2; y := 13 End;
  244.   69: Begin x := FPOS3; y := 13 End;
  245.   70: Begin x := FPOS4; y := 13 End;
  246.   71: Begin x := FPOS5; y := 13 End;
  247.   72: Begin x := FPOS6; y := 13 End;
  248.   73: Begin x := FPOS1; y := 14 End;
  249.   74: Begin x := FPOS2; y := 14 End;
  250.   75: Begin x := FPOS3; y := 14 End;
  251.   76: Begin x := FPOS4; y := 14 End;
  252.   77: Begin x := FPOS5; y := 14 End;
  253.   78: Begin x := FPOS6; y := 14 End;
  254.   79: Begin x := FPOS1; y := 15 End;
  255.   80: Begin x := FPOS2; y := 15 End;
  256.   81: Begin x := FPOS3; y := 15 End;
  257.   82: Begin x := FPOS4; y := 15 End;
  258.   83: Begin x := FPOS5; y := 15 End;
  259.   84: Begin x := FPOS6; y := 15 End;
  260.   85: Begin x := FPOS1; y := 16 End;
  261.   86: Begin x := FPOS2; y := 16 End;
  262.   87: Begin x := FPOS3; y := 16 End;
  263.   88: Begin x := FPOS4; y := 16 End;
  264.   89: Begin x := FPOS5; y := 16 End;
  265.   90: Begin x := FPOS6; y := 16 End;
  266.   91: Begin x := FPOS1; y := 17 End;
  267.   92: Begin x := FPOS2; y := 17 End;
  268.   93: Begin x := FPOS3; y := 17 End;
  269.   94: Begin x := FPOS4; y := 17 End;
  270.   95: Begin x := FPOS5; y := 17 End;
  271.   96: Begin x := FPOS6; y := 17 End;
  272.   97: Begin x := FPOS1; y := 18 End;
  273.   98: Begin x := FPOS2; y := 18 End;
  274.   99: Begin x := FPOS3; y := 18 End;
  275.  100: Begin x := FPOS4; y := 18 End;
  276.  101: Begin x := FPOS5; y := 18 End;
  277.  102: Begin x := FPOS6; y := 18 End;
  278.  103: Begin x := FPOS1; y := 19 End;
  279.  104: Begin x := FPOS2; y := 19 End;
  280.  105: Begin x := FPOS3; y := 19 End;
  281.  106: Begin x := FPOS4; y := 19 End;
  282.  107: Begin x := FPOS5; y := 19 End;
  283.  108: Begin x := FPOS6; y := 19 End;
  284.  109: Begin x := FPOS1; y := 20 End;
  285.  110: Begin x := FPOS2; y := 20 End;
  286.  111: Begin x := FPOS3; y := 20 End;
  287.  112: Begin x := FPOS4; y := 20 End;
  288.  113: Begin x := FPOS5; y := 20 End;
  289.  114: Begin x := FPOS6; y := 20 End;
  290.  115: Begin x := FPOS1; y := 21 End;
  291.  116: Begin x := FPOS2; y := 21 End;
  292.  117: Begin x := FPOS3; y := 21 End;
  293.  118: Begin x := FPOS4; y := 21 End;
  294.  119: Begin x := FPOS5; y := 21 End;
  295.  120: Begin x := FPOS6; y := 21 End
  296.  Else
  297.  Begin
  298.  x := 0;
  299.  y := 0;
  300.  End
  301.   End
  302. End;
  303.  
  304. Procedure HILITE(old,new : Integer); { highlight a filename on the screen }
  305. Var
  306.   i,oldx,oldy,newx,newy : Integer;
  307.   ccolor,locolor,hicolor,cchar : Byte;
  308. Begin
  309.   FNAMEPOS(old,oldx,oldy); { get position in the array of the filename }
  310.   FNAMEPOS(new,newx,newy); { get position in the array of the filename }
  311.   For i := 0 To 11 Do
  312.   Begin
  313.  If old < 121 Then { if valid position, reverse video, old selection }
  314.  Begin
  315.  GoToXY((oldx + i),oldy);
  316.  SCRGET(cchar,ccolor);
  317.  locolor := ccolor AND $0F;
  318.  locolor := locolor shl 4;
  319.  hicolor := ccolor AND $F0;
  320.  hicolor := hicolor shr 4;
  321.  ccolor := locolor + hicolor;
  322.  SCRPUT(cchar,ccolor)
  323.  End;
  324.  GoToXY((newx + i),newy); { reverse video, new selection }
  325.  SCRGET(cchar,ccolor);
  326.  locolor := ccolor AND $0F;
  327.  locolor := locolor shl 4;
  328.  hicolor := ccolor AND $F0;
  329.  hicolor := hicolor shr 4;
  330.  ccolor := locolor + hicolor;
  331.  SCRPUT(cchar,ccolor)
  332.   End
  333. End;
  334.  
  335. Function DIRSELECT(mask : strtype; attr : Integer) : strtype;
  336. Const
  337.   OFF  = FALSE;
  338.   ON= TRUE;
  339. Var
  340.   i,oldcurx,oldcury,
  341.   newcurx,newcury,
  342.   oldpos,newpos,
  343.   scrrows,fncnt: Integer;
  344.   ch  : Char;
  345.   dos_dir : Array[1..120] of String[12];
  346.   fileinfo : SearchRec;
  347.   screen  : Array[1..4000] of Byte;
  348. Begin
  349.   fncnt := 0;
  350.   FindFirst(mask,attr,fileinfo);
  351.   If DosError <> 0 Then  { if not found, return NULL }
  352.   Begin
  353.  DIRSELECT := '';
  354.  Exit
  355.   End;
  356.   While (DosError = 0) AND (fncnt <> 120) Do  { else, collect filenames }
  357.   Begin
  358.  Inc(fncnt);
  359.  dos_dir[fncnt] := fileinfo.Name;
  360.  FindNext(fileinfo)
  361.   End;
  362.   oldcurx := WhereX; { store old CURSOR position }
  363.   oldcury := WhereY;
  364.   SAVESCR(screen);
  365.   CURSOR(OFF);
  366.   scrrows := (fncnt DIV 6) + 3;
  367.   Window(1,1,80,scrrows + 1);
  368.   ClrScr;
  369.   GoToXY(1,1);
  370.   i := 1;
  371.   While (i <= fncnt) AND (i <= 120) Do { display all filenames }
  372.   Begin
  373.  FNAMEPOS(i,newcurx,newcury);
  374.  GoToXY(newcurx,newcury);
  375.  Write(dos_dir[i]);
  376.  Inc(i)
  377.   End;
  378.   FRAME(1,1,scrrows,80,1); { draw the frame }
  379.   HILITE(255,1);{ highlight the first filename }
  380.   oldpos := 1;
  381.   newpos := 1;
  382.   While TRUE Do { get keypress and do appropriate action }
  383.   Begin
  384.  ch := ReadKey;
  385.  Case ch of
  386.  #27: { Esc }
  387.  Begin
  388. Window(1,1,80,25);
  389. RESTORESCR(screen);
  390. GoToXY(oldcurx,oldcury);
  391. CURSOR(ON);
  392. DIRSELECT := '';
  393. Exit  { return NULL }
  394.  End;
  395.  #71: { Home }{ goto first filename }
  396.  Begin
  397. oldpos := newpos;
  398. newpos := 1;
  399. HILITE(oldpos,newpos)
  400.  End;
  401.  #79: { End }{ goto last filename }
  402.  Begin
  403. oldpos := newpos;
  404. newpos := fncnt;
  405. HILITE(oldpos,newpos)
  406.  End;
  407.  #72: { Up  }{ move up one filename }
  408.  Begin
  409. i := newpos;
  410. i := i - 6;
  411. If i >= 1 Then
  412. Begin
  413.   oldpos := newpos;
  414.   newpos := i;
  415.   HILITE(oldpos,newpos)
  416. End
  417.  End;
  418.  #80: { Down }{ move down one filename }
  419.  Begin
  420. i := newpos;
  421. i := i + 6;
  422. If i <= fncnt Then
  423. Begin
  424.   oldpos := newpos;
  425.   newpos := i;
  426.   HILITE(oldpos,newpos)
  427. End
  428.  End;
  429.  #75: { Left }{ move left one filename }
  430.  Begin
  431. i := newpos;
  432. Dec(i);
  433. If i >= 1 Then
  434. Begin
  435.   oldpos := newpos;
  436.   newpos := i;
  437.   HILITE(oldpos,newpos)
  438. End
  439.  End;
  440.  #77: { Right }  { move right one filename }
  441.  Begin
  442. i := newpos;
  443. Inc(i);
  444. If i <= fncnt Then
  445. Begin
  446.   oldpos := newpos;
  447.   newpos := i;
  448.   HILITE(oldpos,newpos)
  449. End
  450.  End;
  451.  #13: { CR }
  452.  Begin
  453. Window(1,1,80,25);
  454. RESTORESCR(screen);
  455. GoToXY(oldcurx,oldcury);{ return old CURSOR position }
  456. CURSOR(ON);
  457. DIRSELECT := dos_dir[newpos];
  458. Exit{ return with filename }
  459.  End
  460.  End
  461.   End
  462. End;
  463.  
  464. { ************************************************************************** }
  465. { ** Main Program : NOTE that the following is a demo program only.  ** }
  466. { **It is not needed to use the DIRSELECT function.  ** }
  467. { ************************************************************************** }
  468.  
  469. Begin
  470.   While TRUE Do
  471.   Begin
  472.  Writeln;
  473.  Write('Enter a filespec => ');
  474.  Readln(spec);
  475.  fname := DIRSELECT(spec,0);
  476.  If Length(fname) = 0 Then
  477.  Begin
  478.  Writeln('Filespec not found.');
  479.  Halt
  480.  End;
  481.  Writeln('The file you have chosen is ',fname,'.')
  482.   End
  483. End.
  484.